home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-load.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-02-18  |  27.0 KB  |  967 lines
  1. /*  $Id: pl-load.c,v 1.43 1998/02/18 13:57:02 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: load foreign files
  8. */
  9.  
  10. /*  Modified (M) 1993 Dave Sherratt  */
  11. /*  Implementing foreign functions for HP-PA RISC architecture  */
  12.  
  13. #include "pl-incl.h"
  14. #ifndef MAXPATHLEN
  15. #define MAXPATHLEN 1024
  16. #endif
  17.  
  18. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  19. Make sure the symbolfile and  orgsymbolfile  attributes  of  the  global
  20. structure status are filled properly.
  21. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  22.  
  23. bool
  24. getSymbols(void)
  25. { char *symbols, *abs_symbols;
  26.   char tmp1[MAXPATHLEN];
  27.   char tmp2[MAXPATHLEN];
  28.  
  29.   if ( loaderstatus.symbolfile != NULL_ATOM )
  30.     succeed;
  31.   
  32.   if ( (symbols = Symbols(tmp1)) == (char *)NULL )
  33.   { symbols = GD->cmdline.argv[0];
  34.     Putf("[WARNING: Failed to find symbol table. Trying %s]\n", symbols);
  35.   }
  36.   DEBUG(2, Sdprintf("Symbol file = %s\n", symbols));
  37.   if ( !(abs_symbols = AbsoluteFile(symbols, tmp2)) )
  38.     fail;
  39.  
  40.   loaderstatus.symbolfile = loaderstatus.orgsymbolfile
  41.               = lookupAtom(abs_symbols);
  42.   setFeature(lookupAtom("symbol_file"), FT_ATOM, loaderstatus.symbolfile);
  43.  
  44.   succeed;
  45. }
  46.  
  47. #if O_FOREIGN
  48.  
  49. forwards bool create_a_out(char *files, char *entry,
  50.                char *options, char *libraries,
  51.                long int base, char *outfile);
  52. forwards int  openExec(char *execFile);
  53. forwards int  sizeExec(void);
  54. forwards Func loadExec(int fd, unsigned long base, char *sentry);
  55. #if O_NOENTRY
  56. forwards bool scanSymbols();
  57. forwards char *symbolString();
  58. #endif
  59.  
  60. #include <sys/file.h>
  61. #include <a.out.h>
  62. #include <unistd.h>
  63.  
  64. #ifdef HAVE_MALLOC_H
  65. #include <malloc.h>            /* valloc() prototype */
  66. #endif
  67.  
  68.  
  69. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  70. Load an object file and link it to the system.  The intented  schema  is
  71. to  call  the  standard  system  loader `ld' to proceduce an incremental
  72. executable starting at some specified address.  As we only need 1  entry
  73. point  (the foreign module's initialisation function) we call the loader
  74. with -e <function> which will make the loader put the  address  of  that
  75. function in the header of the executable, thus avoiding the need to scan
  76. the  symbol table.  With the new dynamic linking facilities of SunOs 4.0
  77. this appears not to work any more.  Therefore a NOENTRY  flag  has  been
  78. introduced  to  indicate that `-e' does not work properly and the symbol
  79. table is to be scanned for the entry point.
  80.  
  81. If the size of the executable is not provided by the user, we first make
  82. an executable for an arbitrary base address (0) to deterimine the  size.
  83. Next  we  allocate  memory  and  produce  an  executable to start at the
  84. allocated memory base.  Finally, we read the text and  initialised  data
  85. segment  from  the  executable,  clear  the  bss area and call the entry
  86. point.
  87.  
  88. Normally, the entry point will install foreign language  functions,  but
  89. the user is allowed to do anything (s)he likes (even take over control).
  90.  
  91. This module is a bit of a mess due to all the #ifdef.  We should  define
  92. a better common basis to get rid of most of these things.
  93. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  94.  
  95. #if hpux
  96. #  ifdef TEXT_OFFSET  /* a.out_300 */
  97. #    define N_DATOFF(x)       DATA_OFFSET(x)
  98. #    define N_TXTOFF(x)       TEXT_OFFSET(x)
  99. #  else                       /* a.out_800 */
  100. #    define aout_800 1
  101. #    define N_TXTOFF(x) ((x).exec_tfile)
  102. #    define N_DATOFF(x) ((x).exec_dfile)
  103. #    define aouthdr som_exec_auxhdr
  104. #    define filehdr header
  105. #    define tsize exec_tsize
  106. #    define dsize exec_dsize
  107. #    define bsize exec_bsize
  108. #    define LD_O_OPTIONS     "-N -a archive"
  109. #    define LD_O_LIBS         "-lc /lib/dyncall.o"
  110. #  endif
  111. #  ifdef EXEC_PAGESIZE
  112. #    define PAGSIZ    EXEC_PAGESIZE
  113. #  else
  114. #    define PAGSIZ    0x1000
  115. #  endif
  116. #endif
  117.  
  118. #if vax
  119. #define PAGSIZ        0x400
  120. #endif
  121.  
  122. #ifndef N_DATOFF            /* SunOs 3.4 does not define this */
  123. #define N_DATOFF(x) ( N_TXTOFF(x) + (x).a_text )
  124. #endif
  125.  
  126. #define ROUND_UP(cp,POWER_OF_TWO) \
  127.   (((unsigned long)(cp)+POWER_OF_TWO-1) & ~(POWER_OF_TWO-1))
  128.  
  129. #define PAGE_ROUND_UP(cp) \
  130.   ROUND_UP(cp,PAGSIZ)
  131.  
  132. #define ADDRESS_ALIGN(cp) \
  133.   ((char *)(PAGE_ROUND_UP(cp)))
  134.  
  135. #if O_NOENTRY
  136. #define MAXSYMBOL 256            /* maximum length of a function name */
  137.  
  138. typedef struct
  139. { char *string;                /* name of function (withouth _) */
  140.   Func function;            /* functions address */
  141. } textSymbol;
  142.  
  143. char *symbolString();            /* forwards */
  144. #endif /* O_NOENTRY */
  145.  
  146. #ifndef aout_800
  147. static struct exec header;            /* a.out header */
  148. #else
  149. struct aouthdr sysHeader;
  150. struct filehdr fileHeader;
  151. #endif
  152.  
  153. void
  154. resetLoader(void)
  155. { loaderstatus.symbolfile = loaderstatus.orgsymbolfile = NULL;
  156. }
  157.  
  158. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  159. Allocate room for text and data segment of executable.  The  SUN  has  a
  160. special  function  for  this  called valloc(). On some systems you might
  161. need to start the text and data segment on a page  boundary,  on  others
  162. not.
  163. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  164.  
  165. #if defined(hpux) || defined(vax)
  166. #  ifndef aout_800
  167. #define valloc malloc
  168. #  else
  169. #define valloc( size )        ADDRESS_ALIGN( malloc( ( size ) + PAGSIZ - 1 ) )
  170. #  endif
  171. #endif
  172.  
  173. long
  174. allocText(long int size)
  175. { long base;
  176.  
  177.   if ( size < sizeof(word) )
  178.     return 0;                /* test run */
  179.  
  180.   size = ROUND(size, sizeof(long));
  181.  
  182.   if ( !(base = (long) valloc(size)) )
  183.     fatalError("%s", OsError());
  184.  
  185.   GD->statistics.heap += size;
  186.  
  187.   return base;
  188. }
  189.  
  190.  
  191. word
  192. pl_load_foreign(term_t file, term_t entry, term_t options,
  193.         term_t libraries, term_t size)
  194. { char *sfile, *sentry, *soptions, *slibraries;
  195.   long sz, nsz, n;
  196.   atom_t execName;
  197.   char *execFile;
  198.   long base;
  199.   int fd;
  200.  
  201.   if ( !PL_get_atom_chars(file, &sfile) ||
  202.        !PL_get_atom_chars(entry, &sentry) ||
  203.        !PL_get_atom_chars(options, &soptions) ||
  204.        !PL_get_atom_chars(libraries, &slibraries) ||
  205.        !PL_get_long(size, &sz) )
  206.     return warning("pl_load_foreign/5: instantiation fault");
  207.  
  208.   if ( sz < 0 )
  209.     sz = 0;
  210.   
  211.   TRY( getSymbols() );
  212.   execName = TemporaryFile("ld");
  213.   execFile = stringAtom(execName);
  214.  
  215.   for( n=0; n<2; n++)
  216.   { base = (long) allocText(sz);
  217.     TRY( create_a_out(sfile, sentry, soptions, slibraries, base, execFile) );
  218.     if ( (fd = openExec(execFile)) < 0 )
  219.       fail;
  220.  
  221.     if ( sizeExec() <= sz )
  222.     { Func entry;
  223.       if ( (entry = loadExec(fd, base, sentry)) == NULL )
  224.         fail;
  225.       loaderstatus.symbolfile = execName;
  226.       DEBUG(1, Sdprintf("Calling entry point at 0x%x\n", entry));
  227.       (*entry)();
  228.       DEBUG(1, Sdprintf("Entry point returned successfully\n"));
  229.  
  230.       succeed;
  231.     }
  232.  
  233.     if ( base > 0 )            /* used for test runs */
  234.       freeHeap(base, sz);
  235.     nsz = sizeExec();
  236.     if ( sz > 0 )
  237.     { Putf("! Executable %s does not fit in %d bytes\n", sfile, sz);
  238. #ifndef aout_800
  239.       Putf("Size: %d bytes (%d text %d data, %d bss) (reloading ...)\n",
  240.         nsz, header.a_text, header.a_data, header.a_bss);
  241. #endif
  242.     }
  243.     sz = nsz;
  244.   }
  245.  
  246.   return sysError("Can't fit executable %s", execFile);
  247. }
  248.  
  249. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  250. Create an a.out file from a .o file.
  251. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  252.  
  253. #ifndef LD_COMMAND
  254. #define LD_COMMAND    "ld"        /* Unix loader command name */
  255. #endif
  256. #ifndef LD_O_OPTIONS
  257. #define LD_O_OPTIONS    "-N"        /* General options */
  258. #endif
  259. #ifndef LD_O_SFILE
  260. #define LD_O_SFILE    "-A %s"        /* symbol file of process */
  261. #endif
  262. #ifndef LD_O_ADDR
  263. #define LD_O_ADDR    "-T %lx"    /* Base address */
  264. #endif
  265. #ifndef LD_O_ENTRY
  266. #define LD_O_ENTRY    "-e _%s"    /* Entry-point */
  267. #endif
  268. #ifndef LD_O_OUT
  269. #define LD_O_OUT    "-o %s"        /* output file */
  270. #endif
  271. #ifndef LD_O_LIBS
  272. #define LD_O_LIBS    "-lc"        /* standard libraries */
  273. #endif
  274.  
  275. static bool
  276. create_a_out(char *files, char *entry, char *options, char *libraries, long int base, char *outfile)
  277. { char command[10240];
  278.   char *s = command;
  279.  
  280. #define next(str) { (str) += strlen(str); *(str)++ = ' '; };
  281.  
  282.   Ssprintf(s, "%s", LD_COMMAND);                     next(s);
  283.   Ssprintf(s, "%s", LD_O_OPTIONS);                 next(s);
  284.   Ssprintf(s, LD_O_SFILE, stringAtom(loaderstatus.symbolfile));   next(s);
  285.   Ssprintf(s, LD_O_ADDR, base);                      next(s);
  286. #if !O_NOENTRY
  287.   Ssprintf(s, LD_O_ENTRY, entry);                 next(s);
  288. #endif
  289.   Ssprintf(s, LD_O_OUT, outfile);                 next(s);
  290.   Ssprintf(s, "%s", options);                     next(s);
  291.   Ssprintf(s, "%s", files);                     next(s);
  292.   Ssprintf(s, "%s", libraries);                     next(s);
  293.   Ssprintf(s, LD_O_LIBS);
  294.  
  295. #undef next
  296.   
  297.   DEBUG(1, Sdprintf("Calling loader: %s\n", command) );
  298.   if (system(command) == 0)
  299.     succeed;
  300.  
  301.   unlink(outfile);
  302.   return warning("load_foreign/5: Failed to create an executable from %s\ncommand was %s",
  303.          files,
  304.          command);
  305. }
  306.  
  307. #ifndef O_BINARY
  308. #define O_BINARY 0
  309. #endif
  310.  
  311. static
  312. int
  313. openExec(char *execFile)
  314. { int fd;
  315.  
  316.                     /* O_BINARY needed on OS2 && EMX  */
  317.   if ((fd=open(execFile, O_RDONLY|O_BINARY)) < 0)
  318.   { warning("load_foreign/5: Cannot open %s", execFile);
  319.     return -1;
  320.   }
  321.  
  322. #ifndef aout_800
  323.   if (read(fd, &header, sizeof(struct exec)) != sizeof(struct exec) ||
  324.       N_BADMAG(header) != 0)
  325.   { warning("load_foreign/5: Bad magic number in %s", execFile);
  326.     close(fd);
  327.     return -1;
  328.   }
  329. #else
  330.   if ( read(fd, &fileHeader, sizeof(fileHeader)) != sizeof(fileHeader) )
  331.   { warning("load_foreign/5: Unable to read file header of %s\n", execFile);
  332.     close(fd);
  333.     return -1;
  334.   }
  335.   if ( fileHeader.aux_header_size == 0 )
  336.   { warning("load_foreign/5: No read aux header in %s\n", execFile);
  337.     close(fd);
  338.     return -1;
  339.   }
  340.   lseek(fd, fileHeader.aux_header_location, 0 );
  341.   if ( read(fd, &sysHeader, sizeof(sysHeader)) != sizeof(sysHeader) )
  342.   { warning("load_foreign/5: Unable to read som header of %s\n", execFile);
  343.     close(fd);
  344.     return -1;
  345.   }
  346. #endif
  347.  
  348.   return fd;
  349. }
  350.  
  351.  
  352. static int
  353. sizeExec(void)
  354. { return
  355. #ifndef aout_800
  356.     ROUND(header.a_text, 4) +
  357.     ROUND(header.a_data, 4) +
  358.     ROUND(header.a_bss, 4);
  359. #else
  360.     PAGE_ROUND_UP(sysHeader.tsize) +
  361.     PAGE_ROUND_UP(sysHeader.dsize) +
  362.     PAGE_ROUND_UP(sysHeader.bsize);
  363. #endif
  364. }
  365.  
  366.  
  367. static Func
  368. loadExec(int fd, unsigned long base, char *sentry)
  369. { Func entry;
  370.   long *text, text_off, text_size;
  371.   long *data, data_off, data_size;
  372.   long *bss, bss_size;
  373.  
  374. #ifndef aout_800
  375.   text = (long *)base;            /* address of text in memory */
  376.   text_size = header.a_text;        /* size of text area */
  377.   data = (long *)(base+text_size);    /* address of data in memory */
  378.   data_size = header.a_data;        /* size of data area */
  379.   text_off = N_TXTOFF(header);        /* offset of text in file */
  380.   data_off = N_DATOFF(header);        /* offset of data in file */
  381.   bss = (long *)(base + text_size + data_size);
  382.   bss_size = header.a_bss;
  383. #else
  384.   text = (long *)sysHeader.exec_tmem; /* address of text in memory */
  385.   text_size = sysHeader.tsize;                /* size of text area */
  386.   data = (long *)sysHeader.exec_dmem; /* address of data in memory */
  387.   data_size = sysHeader.dsize;                /* size of data area */
  388.   text_off = N_TXTOFF(sysHeader);     /* offset of text in file */
  389.   data_off = N_DATOFF(sysHeader);     /* offset of data in file */
  390.   bss = (long *)(data + data_size);
  391.   bss_size = sysHeader.bsize;
  392. #endif
  393.  
  394.   DEBUG(1, Sdprintf("Text offset = %d, Data offset = %d\n", text_off, data_off));
  395.   DEBUG(1, Sdprintf("Base = 0x%x (= %d), text at 0x%x, %d bytes, data at 0x%x, %d bytes\n",
  396.             base, base, text, text_size, data, data_size) );
  397.  
  398.   if ( lseek(fd, text_off, 0) < 0 ||
  399.        text_size != read(fd, text, text_size) ||
  400.        lseek(fd, data_off, 0) < 0 ||
  401.        data_size != read(fd, data, data_size) )
  402.   { warning("load_foreign/5: Failed to read text segment");
  403.     close(fd);
  404.     return NULL;
  405.   }
  406.  
  407. #if O_NOENTRY
  408.   { textSymbol ts[1];
  409.     ts[0].string = sentry;
  410.     ts[0].function = (Func) NULL;
  411.  
  412.     TRY( scanSymbols(fd, 1, ts) );
  413.     entry = ts[0].function;
  414.   }
  415. #else
  416. #  if hpux
  417. #    ifndef aout_800
  418.   entry = (Func)(header.a_entry + (long)text);
  419.   DEBUG(2, Sdprintf("a_entry = 0x%x; text = 0x%x, entry = 0x%x\n",
  420.                 header.a_entry, text, entry));
  421. #    else
  422.   entry = (Func)(sysHeader.exec_entry);
  423.   DEBUG(2, Sdprintf("exec_entry = 0x%x; text = 0x%x, entry = 0x%x\n",
  424.                               sysHeader.exec_entry, text, entry));
  425. #    endif
  426. #  else
  427.   entry = (Func)(header.a_entry);
  428. #  endif
  429. #endif
  430.  
  431.   close(fd);
  432.  
  433.   DEBUG(1, Sdprintf("Cleaning BSS %d bytes from 0x%x (=%d)\n", 
  434.           bss_size, bss, bss));
  435.   memset(bss, 0, bss_size);
  436.  
  437.   return entry;
  438. }
  439.  
  440. #if O_NOENTRY
  441. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  442. Scan the symbol table and try to resolve all textSymbols given  in  `tv'
  443. (target  vector).   The  first `tc' (target count) members of this array
  444. are valid.  TRUE is returned if  all  functions  are  found.   Otherwise
  445. FALSE is returned.
  446.  
  447. Searching starts at the end of the symbol table, as this  is  the  place
  448. were the incrementally loaded symbols normally lives.
  449.  
  450. It assumes a global struct exec `header'  to  hold  the  header  of  the
  451. symbol  file and the argument `fd' to be an open file descriptor on that
  452. file.
  453. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  454.  
  455. static bool
  456. scanSymbols(fd, tc, tv)
  457. int fd;
  458. int tc;
  459. textSymbol * tv;
  460. { long symbols, strings;
  461.   long next_symbol;
  462.   struct nlist name;
  463.   char *s;
  464.   int n, left = tc;
  465.  
  466.   symbols = N_SYMOFF(header);
  467.   strings = N_STROFF(header);
  468.  
  469.   n = (strings - symbols)/sizeof(struct nlist);
  470.   next_symbol = symbols+(n-1)*sizeof(struct nlist);
  471.  
  472.   for(; next_symbol >= symbols; next_symbol -= sizeof(struct nlist) )
  473.   { if (lseek(fd, next_symbol, 0) < 0)
  474.       return warning("seek on executables' symbol table failed");
  475.     if (read(fd, &name, sizeof(struct nlist) ) != sizeof(struct nlist) )
  476.       return warning("failed to read symbol in executable");
  477.  
  478.     if (name.n_type == (unsigned char)(N_TEXT|N_EXT))
  479.     { s = symbolString(fd, name.n_un.n_strx+strings);
  480.  
  481.       for(n = 0; n < tc; n++)
  482.       { if ( streq(tv[n].string, s+1) )
  483.     { tv[n].function = (Func) name.n_value;
  484.       if ( --left <= 0 )
  485.         succeed;
  486.     }
  487.       }
  488.     }
  489.   }
  490.  
  491.   if ( left > 0 )
  492.   { for(n = 0; n < tc; n++)
  493.     { if ( tv[n].function == (Func) NULL )
  494.         warning("Dynamic loader: undefined: %s", tv[n].string);
  495.     }
  496.     fail;
  497.   }
  498.   succeed;
  499. }
  500.  
  501. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  502. Return the char string at offset `n' in the string table.   The  strings
  503. are supposed not to be longer than MAXSYMBOL characters.
  504. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  505.  
  506. static char *
  507. symbolString(fd, n)
  508. int fd;
  509. long n;
  510. { static char temp[MAXSYMBOL+1];
  511.   int l;
  512.  
  513.   if (n == 0)
  514.     return "";
  515.   if (lseek(fd, n, 0) < 0)
  516.   { warning("Failed to seek to string in executable");
  517.     return (char *) NULL;
  518.   }
  519.   l = read(fd, temp, MAXSYMBOL);
  520.   temp[l] = EOS;
  521.  
  522.   return temp;
  523. }
  524.  
  525. #endif /* O_NOENTRY */
  526.  
  527. #else
  528.  
  529. #if O_AIX_FOREIGN
  530. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  531. The AIX foreign interface  is completely different to the SUN/VAX/HPUX
  532. version.  The  latter cannot  be used  because ld is  lacking   the -A
  533. option and AIX uses  XCOFF  format a.out files.  Instead, AIX supplies
  534. the  load()  and loadbind() functions  to   load executable  code in a
  535. running  image.   This makes   the implementation a   lot  easier (and
  536. supported by official functions).
  537.  
  538. There is  still a problem in  the cooperation with save_program/[1,2].
  539. Normally, it appears the foreign code is loaded in  the program's data
  540. area and save nicely  by save_program.  If the loaded   code  is small
  541. however it will be put below &_data, in  which case save_program won't
  542. see it.   Currently,  there is  only detection  of  this  problem.  We
  543. should try  to figure out  the starting adres  of the loaded code  and
  544. communicate this to save_program.  How to do this?
  545.  
  546. Note  than  the  Prolog   part    is  also different    for AIX.   See
  547. boot/aixforeign.pl.
  548. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  549.  
  550. #include <sys/ldr.h>
  551.  
  552. static Func main_entry;        /* my entry-point */
  553.  
  554. void
  555. resetLoader()
  556. { loaderstatus.symbolfile = loaderstatus.orgsymbolfile = NULL;
  557.   main_entry = NULL;
  558. }
  559.  
  560. word
  561. pl_load_foreign1(term_t file)
  562. { char *sfile;
  563.   atom_t name;
  564.   long rval;
  565.   Func entry;
  566.   char *libpath;
  567.   int len;
  568.   extern int _data;
  569.  
  570.   if ( (len = getenvl("LIBPATH")) >= 0 )
  571.   { libpath = alloca(len+1);
  572.     getenv3("LIBPATH", libpath, len+1);
  573.   } else
  574.     libpath = "/lib:/usr/lib";
  575.  
  576.   if ( !PL_get_atom(file, &name) )
  577.     return warning("pl_load_foreign/5: instantiation fault");
  578.   sfile = stringAtom(name);
  579.  
  580.   if ( main_entry == NULL )
  581.   { char *me;
  582.  
  583.     TRY(getSymbols());
  584.     me = stringAtom(loaderstatus.symbolfile);
  585.  
  586.     DEBUG(1, Sdprintf("Loading %s ... ", me));
  587.     if ( (main_entry = (Func) load(me, L_NOAUTODEFER, libpath)) == NULL )
  588.       return warning("load_foreign/5: %s: %s", me, OsError());
  589.     DEBUG(1, Sdprintf("ok\n"));
  590.   }
  591.  
  592.   DEBUG(1, Sdprintf("Loading %s ... ", sfile));
  593.   if ((entry = (Func) load(sfile, L_NOAUTODEFER, libpath)) == NULL)
  594.   { char *buf[1024];
  595.     warning("load_foreign/5: %s: %s", sfile, OsError());
  596.  
  597.     buf[0] = "execerror";
  598.     buf[1] = sfile;
  599.     if ( loadquery(L_GETMESSAGES, &buf[2], sizeof(buf) - 8) < 0 )
  600.       warning("load_foreign/5: loadquery: %s", OsError());
  601.     else
  602.     { switch ( fork() )
  603.       { case 0:
  604.       execvp("/etc/execerror", buf);
  605.     case -1:
  606.       warning("Couldn't exec /etc/execerror: %s", OsError());
  607.       }
  608.     }
  609.     fail;
  610.   }
  611.   DEBUG(1, Sdprintf("ok\n"));
  612.  
  613.   if ( entry < (Func) &_data )
  614.     GD->cannot_save_program = "Foreign code loaded outside data area";
  615.  
  616.   DEBUG(1, Sdprintf("Loadbind() ... "));
  617.   if ( loadbind(0, main_entry, entry) != 0 )
  618.     return warning("load_foreign/5: loadbind: %s", OsError());
  619.   DEBUG(1, Sdprintf("ok\n"));
  620.  
  621.   DEBUG(1, Sdprintf("Calling entry-point at 0x%x\n", entry));
  622.   rval = (*entry)();
  623.   DEBUG(1, Sdprintf("rval = %d (0x%x)\n", rval, rval));
  624.  
  625.   succeed;
  626. }
  627.  
  628. #else
  629.  
  630. #if O_MACH_FOREIGN
  631. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  632. The NeXT foreign interface is completely   different to the SUN/VAX/HPUX
  633. version.  The latter cannot be used because   the  NeXT uses MACH format
  634. a.out files.  Instead, MACH  supplies   the  rld_load() and rld_lookup()
  635. functions to load executable code in a   running  image.  This makes the
  636. implementation a lot easier (and supported by official functions).
  637.  
  638. The prolog part is identical to  the   SUN  versions.  However, the only
  639. arguments of load_foreign/5 that are used   are 'File', 'Libraries', and
  640. 'Entry'.  The other arguments are ignored.   'Libraries' is not expanded
  641. by the C code; filenames should be  either full pathnames or 'library()'
  642. names that expand to a full pathname.
  643. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  644.  
  645. #ifdef HAVE_MACH_O_RLD_H
  646. #include <mach-o/rld.h>
  647. #else
  648. #include <rld.h>
  649. #endif
  650. #include <strings.h>
  651. #include <streams/streams.h>
  652.  
  653. extern int unlink(const char *), mkstemp (char *template), close(int);
  654. extern char *mktemp(char *template);
  655.  
  656. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  657. the rld_...  routines  spew  their  complaints   on  a  stream  of  type
  658. NXStream.  We do not want to print   these to Serror or Soutput, because
  659. the 'current stream' mechanism of prolog   is  circumvented in this way.
  660. We open a temp file instead, informing the user this file exists only if
  661. an error occurred and errno == 0.
  662.  
  663. Be aware of the fact rld_load() may fail   and not set errno to !0.  For
  664. example,  the  call  rld_load(rld_err_stream,_,"i_do_not_exist",_)  will
  665. result in the string "rld(): Can't open: i_do_not_exist (No such file or
  666. directory, errno = 2)" being sent to  the appropriate stream, with errno
  667. ==  2,  while  the  call  rld_load(rld_err_stream,_,"/dev/null",_)  will
  668. result in "rld(): file: /dev/null is empty (not an object or archive)"
  669. being printed, with errno == 0.
  670. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  671.  
  672. word
  673. pl_load_foreign(term_t file, term_t entry, term_t options,
  674.         term_t libraries, term_t size)
  675. { char *sfile, *sentry, *soptions, *slibraries;
  676.  
  677.   struct mach_header *m_header;
  678.   long rld_result, rval;
  679.   unsigned long rld_adress;
  680.   Func entry_func;
  681.   char **object_filenames;
  682.   char *tmp;
  683.   int stringno, maxstrings, i;
  684.  
  685.   /* errorhandling */
  686.   char      *errorBuffer;
  687.   int        streamLength, maxLength;
  688.   NXStream  *rld_err_stream;
  689.   
  690.   char underscore = '_';
  691.  
  692.   rld_err_stream = NXOpenMemory(NULL,0,NX_WRITEONLY);
  693.  
  694.   if ( !PL_get_atom_chars(file, &sfile) ||
  695.        !PL_get_atom_chars(entry, &sentry) ||
  696.        !PL_get_atom_chars(libraries, &slibraries) ) 
  697.     return warning("pl_load_foreign/5: instantiation fault");
  698.  
  699.   /* append object-files and libraries */
  700.   if (strlen(slibraries) > 0)
  701.     sfile = strcat(strcat(sfile," "),slibraries);
  702.   
  703.   /* as *file as well as *libraries may point to a string containing >1
  704.    * filename, we have to break *sfile up in pieces, in order to get 
  705.    * the type of argument rld_load() expects: char **
  706.    */
  707.    
  708.       /* estimate max number of sub-strings in string */
  709.    maxstrings = (strlen(sfile)/ 2) +1;
  710.    if ((object_filenames = 
  711.       (char **)calloc((size_t)maxstrings,sizeof(char *))) == (void *)NULL)
  712.      fatalError("%s", OsError());
  713.  
  714.    stringno = 0;
  715.    if (*sfile != '\0') 
  716.       do {
  717.         object_filenames[stringno] = sfile; /* sub-string */
  718.         tmp = strchr(sfile,' '); /* try to find a space */
  719.         if (tmp != (char *)0) /* space found */
  720.         {  *tmp = '\0'; /* terminate previous string (replace ' ' by '\0') */
  721.            stringno++;
  722.           tmp++; sfile = tmp;            
  723.         } else { /* no space left in string pointed to by tmp */
  724.            object_filenames[stringno + 1] = NULL; /* signals end of char** to rld_load */
  725.         }
  726.       } while (tmp != (char *)0); /* end of sfile reached */
  727.    else /* sfile == "" */
  728.      object_filenames[0] = NULL;
  729.    
  730.   DEBUG(1, 
  731.     Sdprintf("Calling rld_load(), file(s):\n");
  732.     for (i = 0; i <= stringno; i++)
  733.       Sdprintf("\t \"%s\"\n",object_filenames[i]));
  734.   
  735.   rld_result = rld_load(rld_err_stream,&m_header,object_filenames,NULL);
  736.   /* get rid of these as soon as we can */
  737.   free((void *)object_filenames);
  738.  
  739.   if (rld_result == 0) 
  740.   {     
  741.     NXFlush(rld_err_stream);
  742.     NXGetMemoryBuffer(rld_err_stream, &errorBuffer, &streamLength, &maxLength);
  743.     warning("load_foreign/5: rld_load() failed (%s)",errorBuffer);
  744.     NXCloseMemory (rld_err_stream, NX_FREEBUFFER);
  745.     fail;
  746.   } 
  747.   DEBUG(1, Sdprintf("\nrld_load returned ok (adress of mach-header: %ld)\n",m_header));
  748.  
  749.   DEBUG(1, Sdprintf("Calling rld_lookup()\n"));
  750.   /* Add an underscore to sentry (as in symbol-table looked at by 
  751.    * rld_lookup())
  752.    *
  753.    *     Problems:
  754.    *
  755.    * Rld_error_stream not used here; rld_lookup() seems to alter
  756.    * the stream; even if the stream * is NOT passed to it !!
  757.    * Functions using the stream dump core on us;
  758.    * unfortunately I can't replicate the error in a small program.
  759.    */ 
  760.   if ( rld_lookup(NULL,strcat(&underscore,sentry), &rld_adress) == 0 )
  761.   {
  762.     warning("load_foreign/5: rld_lookup() of \"%s()\" failed",sentry);
  763.     fail;
  764.   }
  765.   DEBUG(1, Sdprintf("rld_lookup returned ok\n"));
  766.  
  767.   entry_func = (Func)rld_adress;
  768.   DEBUG(1, Sdprintf("Calling entry-point at 0x%x\n", entry_func));
  769.   rval = (*entry_func)();
  770.   if (!rval > 0) {
  771.       warning("load_foreign/5: entry-function failed (%s())",sentry);
  772.     fail;
  773.   }
  774.   DEBUG(1, Sdprintf("Entry point returned successfully\n"));
  775.   DEBUG(1, Sdprintf("rval = %d (0x%x)\n", rval, rval));
  776.   
  777.   succeed;
  778. }
  779.  
  780. void
  781. resetLoader()
  782. { loaderstatus.symbolfile = loaderstatus.orgsymbolfile = NULL;
  783. }
  784.  
  785. #else                    /* No foreign language interface */
  786.  
  787. void
  788. resetLoader()
  789. { loaderstatus.symbolfile = loaderstatus.orgsymbolfile = NULL_ATOM;
  790. }
  791.  
  792. word
  793. pl_load_foreign(term_t file, term_t entry, term_t options,
  794.         term_t libraries, term_t size)
  795. {
  796. #if defined(HAVE_DLOPEN) || defined(HAVE_SHL_LOAD) || defined(O_DLL)
  797.   warning("load_foreign/[2,5] are not available for this machine\n"
  798.       "\thowever, the predicates from `library(shlib)' are available");
  799. #else
  800.   warning("load_foreign/[2,5] are not available for this machine");
  801. #endif
  802.  
  803.   fail;
  804. }
  805.  
  806. #endif /* O_MACH_FOREIGN */
  807. #endif /* O_AIX_FOREIGN */
  808. #endif /* O_FOREIGN */
  809.  
  810.          /*******************************
  811.          *     DLOPEN() AND FRIENDS    *
  812.          *******************************/
  813.  
  814. #ifdef HAVE_DLOPEN            /* sysvr4, elf binaries */
  815.  
  816. #include <dlfcn.h>
  817.  
  818. #ifndef RTLD_GLOBAL            /* solaris defines this */
  819. #define RTLD_GLOBAL 0
  820. #endif
  821. #ifndef RTLD_NOW            /* implicit on some versions */
  822. #define RTLD_NOW 0
  823. #endif
  824. #ifndef RTLD_LAZY            /* freeBSD doesn't have this? */
  825. #define RTLD_LAZY 0
  826. #endif
  827.  
  828. #endif /*HAVE_DLOPEN*/
  829.  
  830. #ifdef HAVE_SHL_LOAD            /* HPUX */
  831.  
  832. #include <dl.h>
  833. #define dlopen(path, flags) shl_load((path), (flags), 0L)
  834. #define dlclose(handle)        shl_unload((handle))
  835. #define dlerror() OsError()
  836.  
  837. void *
  838. dlsym(shl_t handle, const char *name)
  839. { void *value;
  840.  
  841.   if ( shl_findsym(&handle, name, TYPE_PROCEDURE, &value) < 0 )
  842.     return NULL;
  843.  
  844.   return value;
  845. }
  846.  
  847. #define RTLD_LAZY    BIND_DEFERRED
  848. #ifdef BIND_IMMEDIATE
  849. #define RTLD_NOW    BIND_IMMEDIATE
  850. #else
  851. #define RTLD_NOW     0
  852. #endif
  853. #define RTLD_GLOBAL    0
  854.  
  855. #endif
  856.  
  857. #if defined(HAVE_DLOPEN) || defined(HAVE_SHL_LOAD)
  858.  
  859. typedef int (*dl_funcptr)();
  860.  
  861. typedef struct dl_entry *DlEntry;
  862. struct dl_entry
  863. { int      id;                /* Prolog's identifier */
  864.   void   *dlhandle;            /* DL libraries identifier */
  865.   atom_t  file;                /* Loaded filed */
  866.   DlEntry next;                /* Next in table */
  867. };
  868.  
  869. int    dl_plid;            /* next id to give */
  870. DlEntry dl_head;            /* loaded DL's */
  871. DlEntry dl_tail;            /* end of this chain */
  872.  
  873. #define DL_NOW      0x1
  874. #define DL_GLOBAL 0x2
  875.  
  876. word
  877. pl_open_shared_object(term_t file, term_t plhandle,
  878.               term_t flags)
  879. { void *dlhandle;
  880.   atom_t afile;
  881.   DlEntry e;
  882.   int dlflags;
  883.   int n;
  884.  
  885.   if ( PL_get_integer(flags, &n) )
  886.   { dlflags = (n & DL_NOW) ? RTLD_NOW : RTLD_LAZY;
  887.     if ( n & DL_GLOBAL )
  888.       dlflags |= RTLD_GLOBAL;
  889.   } else
  890.     dlflags = RTLD_LAZY | RTLD_GLOBAL;
  891.  
  892.   if ( !PL_get_atom(file, &afile) )
  893.     return warning("open_shared_object/2: instantiation fault");
  894.   if ( !(dlhandle = dlopen(stringAtom(afile), dlflags)) )
  895.     return warning("open_shared_object/2: %s", dlerror());
  896.   e = allocHeap(sizeof(struct dl_entry));
  897.   e->id       = ++dl_plid;
  898.   e->dlhandle = dlhandle;
  899.   e->file     = afile;
  900.   e->next     = NULL;
  901.   if ( !dl_tail )
  902.     dl_head = dl_tail = e;
  903.   else
  904.     dl_tail->next = e;
  905.  
  906.   return PL_unify_integer(plhandle, e->id);
  907. }
  908.  
  909.  
  910. static DlEntry
  911. find_dl_entry(term_t h)
  912. { DlEntry e;
  913.   int id;
  914.  
  915.   if ( PL_get_integer(h, &id) )
  916.   { for(e = dl_head; e; e = e->next)
  917.       if ( e->id == id )
  918.     return e;
  919.   }
  920.  
  921.   return NULL;
  922. }
  923.  
  924.  
  925. word
  926. pl_close_shared_object(term_t plhandle)
  927. { DlEntry e = find_dl_entry(plhandle);
  928.  
  929.   if ( e && e->dlhandle) 
  930.   { dlclose(e->dlhandle);
  931.     e->dlhandle = NULL;
  932.  
  933.     succeed;
  934.   }
  935.  
  936.   fail;
  937. }
  938.  
  939.  
  940. word
  941. pl_call_shared_object_function(term_t plhandle, term_t name)
  942. { DlEntry e = find_dl_entry(plhandle);
  943.   char *fname;
  944.   dl_funcptr ef;
  945.  
  946.   if ( !e || !e->dlhandle )
  947.     return warning("call_shared_object_function/2: bad handle");
  948.   if ( !PL_get_chars(name, &fname, CVT_ALL) )
  949.     return warning("call_shared_object_function/2: instantiation fault");
  950.   
  951.   if ( !(ef = (dl_funcptr) dlsym(e->dlhandle, fname)) )
  952.     fail;
  953.  
  954.   (*ef)();
  955.  
  956.   succeed;
  957. }
  958.  
  959. #else /*HAVE_DLOPEN*/
  960.  
  961. word
  962. pl_open_shared_object(term_t file, term_t plhandle, term_t flags)
  963. { return warning("open_shared_object/3: not ported to this machine");
  964. }
  965.  
  966. #endif /*HAVE_DLOPEN*/
  967.